home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue31 / webcomm / HTSHOPC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-01-14  |  10.7 KB  |  339 lines
  1. unit HtShopC;
  2.  
  3. // Original code provided by HREF Tools Corporation, Inc.
  4. // http://www.href.com
  5.  
  6. // Amendments (mainly the WebCreditCard1Execute event and
  7. // TICVerifyTransactionQueuer handling)
  8. // by P J Hyde, South Pacific Information Services Ltd
  9. // http://www.spis.co.nz
  10.  
  11. interface
  12.  
  13. uses
  14.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  15.   UTPANFRM, ExtCtrls, StdCtrls, TpLabel, Toolbar, WebMail, WebSock,
  16.   DBTables, DB, WdbSorce, UpdateOk, tpAction, WebTypes, WebIniFL, WebLink,
  17.   WdbLink, WdbScan, WdbGrid, ebutton, TpMemo, WebMemo, DBCtrls, Buttons,
  18.   Grids, DBGrids, ComCtrls, tpStatus, TpMenu, WebCCard, webtrans;
  19.  
  20. type
  21.   TfmShopPanel = class(TutParentForm)
  22.     ToolBar: TtpToolBar;
  23.     WebDataGrid1: TWebDataGrid;
  24.     WebActionOrderList: TWebAction;
  25.     WebActionPostLit: TWebAction;
  26.     WebDataSource1: TWebDataSource;
  27.     DataSource1: TDataSource;
  28.     Table1: TTable;
  29.     Table1PartNo: TFloatField;
  30.     Table1VendorNo: TFloatField;
  31.     Table1Description: TStringField;
  32.     Table1OnHand: TFloatField;
  33.     Table1OnOrder: TFloatField;
  34.     Table1Cost: TCurrencyField;
  35.     Table1ListPrice: TCurrencyField;
  36.     Table1Qty: TSmallintField;
  37.     WebActionMailer: TWebAction;
  38.     tpStatusBar1: TtpStatusBar;
  39.     tpToolButton1: TtpToolButton;
  40.     Label7: TLabel;
  41.     tpDataModule1: TtpDataModule;
  42.     tpComponentPanel2: TtpComponentPanel;
  43.     PageControl1: TPageControl;
  44.     TabSheet1: TTabSheet;
  45.     DBGrid1: TDBGrid;
  46.     DBNavigator1: TDBNavigator;
  47.     tsEConfig: TTabSheet;
  48.     Label4: TLabel;
  49.     Label5: TLabel;
  50.     Label6: TLabel;
  51.     Label8: TLabel;
  52.     Label9: TLabel;
  53.     EditEMailFrom: TEdit;
  54.     EditEMailTo: TEdit;
  55.     EditMailhost: TEdit;
  56.     EditSubject: TEdit;
  57.     EditMailPort: TEdit;
  58.     GroupBox1: TGroupBox;
  59.     GroupBox2: TGroupBox;
  60.     waScrollGrid: TWebAction;
  61.     WebCreditCard1: TWebCreditCard;
  62.     WebactionQueueTransaction: TWebAction;
  63.     ICVerifyTransactionQueuer: TICVerifyTransactionQueuer;
  64.     procedure Table1QtyGetText(Sender: TField; var Text: string;
  65.       DisplayText: Boolean);
  66.     procedure WebActionPostLitExecute(Sender: TObject);
  67.     procedure WebActionOrderListExecute(Sender: TObject);
  68.     procedure WebActionMailerExecute(Sender: TObject);
  69.     procedure tpToolButton1Click(Sender: TObject);
  70.     procedure waScrollGridExecute(Sender: TObject);
  71.     procedure WebCreditCard1Execute(Sender: TObject);
  72.     procedure WebactionQueueTransactionExecute(Sender: TObject);
  73.   private
  74.     { Private declarations }
  75.     procedure getOrderList( sList: TStringList );
  76.     procedure ConfigEMail;
  77.   public
  78.     { Public declarations }
  79.     function Init: Boolean; override;
  80.   end;
  81.  
  82. var
  83.   fmShopPanel: TfmShopPanel;
  84.  
  85. implementation
  86.  
  87. {$R *.DFM}
  88.  
  89. uses
  90.   WebApp, ucString, whMail, Appmain;
  91.  
  92. //------------------------------------------------------------------------------
  93.  
  94. function TfmShopPanel.Init:Boolean;
  95. begin
  96.   Result:= inherited Init;
  97.   if not result then
  98.     exit;
  99.   //
  100.   with webdatagrid1 do
  101.     if not isUpdated then refresh;
  102.   //
  103.   fmWebMail.webmail.subject:='';   // init so that we know to config later.
  104.   //
  105.   {Other required settings:
  106.   twebdatagrid
  107.     datascanoptions        all set to true, except refresh and checkboxes
  108.     buttonsWhere           above
  109.     controlsWhere          none
  110.  
  111.   twebdatasource
  112.     maxOpenDataSets        1 (no cloning)
  113.     displaySets            defined in .ini file
  114.  
  115.   TTable
  116.     add fields using Delphi field editor
  117.     add calculated field called Qty, type integer
  118.   }
  119. end;
  120.  
  121. //------------------------------------------------------------------------------
  122. //------------------------------------------------------------------------------
  123.  
  124. procedure TfmShopPanel.ConfigEMail;
  125. begin
  126.   {configure email based on values on form. These are saved to the
  127.    href.ini file by the Restorer component.}
  128.   // e-mail settings -- please change to use your own defaults!
  129.   if EditEMailFrom.text='' then EditEMailFrom.text:='someone@theweb.com';
  130.   if EditEMailTo.text=''   then EditEMailTo.text:='info@href.com';
  131.   if EditMailHost.text=''  then EditMailHost.text:='mail.href.com';
  132.   if EditMailPort.text=''  then EditMailPort.text:='25';
  133.   if EditSubject.text=''   then EditSubject.text:='** Shop1 Sale';
  134.   //
  135.   with fmWebMail.webmail do begin
  136.     Sender.EMail:=EditEmailFrom.text;
  137.     MailTo.clear;
  138.     MailTo.add(editEMailTo.text);
  139.     MailHost.hostname:=EditMailhost.text;
  140.     MailHost.port:=StrToIntDef(EditMailport.text,25);
  141.     Subject:=EditSubject.text;
  142.     end;
  143. end;
  144.  
  145. { ------------------------------------------------------------------------- }
  146.  
  147. { To see what webhub is doing with your data, add %=chDebugInfo=% to the
  148.   bottom of the homepage and/or confirm pages.  That will display some
  149.   key arrays: webserver.dbFields, webserver.FormLiterals and websession.Literals.
  150.  
  151.   The data entered by the surfer into the webdatagrid is posted to the
  152.   dbFields array.  We need to jump in and copy that to the Literals array,
  153.   because dbFields is cleared at the end of the page.  Since we don't have
  154.   a real table to post to, we are using the Literals array as temporary
  155.   storage.  (Yes, you could add a temporary order table and post Qty there.)
  156. }
  157. procedure TfmShopPanel.WebActionPostLitExecute(Sender: TObject);
  158. var
  159.   a1,a2:string;
  160.   i:integer;
  161. begin
  162.   //WebDataSource1.Qty@1316=35
  163.   with TWebAction(Sender).WebApp do begin
  164.     for i:=0 to pred(WebServer.dbFields.count) do begin
  165.       SplitString(WebServer.dbFields[i],'=',a1,a2);
  166.       if a2<>'' then
  167.         Literal[a1]:=a2;   {post single entry to Literals array}
  168.       end;
  169.     end;
  170. end;
  171.  
  172. { ------------------------------------------------------------------------- }
  173.  
  174. { Illusion central:
  175.   Make the table act multi-surfer by defining the calculated field as equal to
  176.   the current surfer's Literals.}
  177. procedure TfmShopPanel.Table1QtyGetText(Sender: TField; var Text: string;
  178.   DisplayText: Boolean);
  179. begin
  180.   Text:=pWebApp.Literal['webdatasource1.Qty@'+
  181.     Sender.DataSet.FieldByName('PartNo').asString];
  182. end;
  183.  
  184.  
  185. { ------------------------------------------------------------------------- }
  186. { ------------------------------------------------------------------------- }
  187.  
  188. {Fill a stringlist with the current order.
  189.  Loop thru the Literals[] array looking for items with @ which come from the
  190.  data entry session.}
  191. procedure TfmShopPanel.getOrderList( sList: TStringList );
  192. var
  193.   a1,a2:string;
  194.   i:integer;
  195. begin
  196.   slist.clear;
  197.   with pWebApp.WebSession do begin
  198.     for i:=0 to pred(Literals.count) do begin
  199.       a1:=LeftOfEqual(Literals[i]);
  200.       if pos( '@', a1 ) > 0 then begin
  201.         //WebDataSource1.Qty@1316=35
  202.         SplitString(Literals[i],'=',a1,a2);  // SplitString is in the ucString unit
  203.         slist.add( 'Qty ' + a2 + ' of Product #' + RightOf( '@', a1 ));
  204.         end;
  205.       end;
  206.     end;
  207. end;
  208.  
  209.  
  210. { ------------------------------------------------------------------------- }
  211.  
  212. {this is one way to echo the current order.}
  213. procedure TfmShopPanel.WebActionOrderListExecute(Sender: TObject);
  214. var
  215.   sList:TStringList;
  216. begin
  217.   sList:=nil;
  218.   try
  219.     sList:=TStringList.create;
  220.     getOrderList(slist);
  221.     //send out the order, with a <BR> at end of each line
  222.     TWebAction(Sender).WebApp.WebOutput.SendStringListBR(slist);
  223.   finally
  224.     slist.free;
  225.     end;
  226. end;
  227.  
  228. { ------------------------------------------------------------------------- }
  229.  
  230. { Prepare and send mail message.}
  231. procedure TfmShopPanel.WebActionMailerExecute(Sender: TObject);
  232. var
  233.   sList:TStringList;
  234. begin
  235.   with TWebAction(Sender).WebApp, fmWebMail.webmail do begin
  236.     if subject='' then
  237.       configEMail;
  238.     //
  239.     Sender.Name:=Literal['CustFullName'];
  240.     // fill in the message (Lines property)
  241.     Lines.clear;
  242.     Lines.add( 'CUSTOMER:' );
  243.     Lines.add( Literal['CustFullName'] );
  244.     Lines.add( Literal['CustCity'] );
  245.     Lines.add( '' );
  246.     Lines.add( 'ORDER:' );
  247.     sList:=nil;
  248.     try
  249.       sList:=TStringList.create;
  250.       getOrderList(slist);
  251.       Lines.AddStrings(slist);
  252.     finally
  253.       slist.free;
  254.       end;
  255.     execute;  {send the message}
  256.     end;
  257. end;
  258.  
  259. { ------------------------------------------------------------------------- }
  260.  
  261. { fun with tool buttons...}
  262.  
  263. procedure TfmShopPanel.tpToolButton1Click(Sender: TObject);
  264. begin
  265.   with DBGrid1 do
  266.     if DataSource=nil then begin
  267.       DataSource:=DataSource1;
  268.       DbNavigator1.DataSource:=DataSource1;
  269.       end
  270.     else begin
  271.       DataSource:=nil;
  272.       DbNavigator1.DataSource:=nil;
  273.       end
  274. end;
  275.  
  276.  
  277.  
  278.  
  279.  
  280. procedure TfmShopPanel.waScrollGridExecute(Sender: TObject);
  281. var
  282.   a1,a2:string;
  283. begin
  284.   inherited;
  285.   with TWebAction(Sender).WebApp do begin
  286.     SplitString(Literal['BtnShop'],' ',a1,a2);  // e.g. Next Page
  287.     WebDataGrid1.Command:=a1;  // e.g. Next
  288.     end;
  289. end;
  290.  
  291. procedure TfmShopPanel.WebCreditCard1Execute(Sender: TObject);
  292. begin
  293.   inherited;
  294.   with WebCreditCard1,WebCreditCard1.WebApp do
  295.   begin
  296.     if CompareText(Command,'CLEAR')=0 then exit;{ No check if clearing }
  297.     if (not Accept) or                          { Bad CC number/date }
  298.          (Literal['CardHolderName']='') then    { Blank name }
  299.     begin
  300.       Literal['CardProblem']:='Yes';            { Flag the problem }
  301.       WebOutput.send('%=Bounce|confirm=%');     { Bounce back to card entry form}
  302.     end else
  303.       Literal['CardProblem']:='';               { Clear any prior flag }
  304.   end;
  305. end;
  306.  
  307. procedure TfmShopPanel.WebactionQueueTransactionExecute(Sender: TObject);
  308. begin
  309.   inherited;
  310.  
  311.   with WebActionQueueTransaction,WebActionQueueTransaction.WebApp,
  312.       ICVerifyTransactionQueuer,ICVerifyTransactionQueuer.TransactionData do
  313.   begin
  314.     if CompareText(Command,'CHECK')<>0 then // not a check...
  315.     begin // must be a full Queue...
  316.       // as the Creditcard component's details are about to
  317.       // be cleared (for security), we'll copy relevant details
  318.       // to some literals
  319.       Literal['_CardNum']:= StripString(WebCreditCard1.CardNumber,' ');
  320.       Literal['_ExpMonth']:=Leftof('/',WebCreditCard1.ExpirationDate);
  321.       Literal['_ExpYear']:= Rightof('/',WebCreditCard1.ExpirationDate);
  322.     end;
  323.  
  324.     // now do the transaction (Check or Queue is the same, in effect)
  325.     TransactionID := IntToStr(Session); // guaranteed unique for THIS surfer
  326.     TransactionAmount :='20.00'; // of course, this should REALLY come from the Webapp
  327.            // via a form literal! This demo just doesn't happen to do pricing...
  328.     CardNumber := Literal['_CardNum'];
  329.     ExpiryMonth := Literal['_ExpMonth'];
  330.     ExpiryYear := Literal['_ExpYear'];
  331.     QueueTransaction;
  332.     Literal['TransStatus'] := StatusMessage+' at '+DateTimeToStr(Age);
  333.     if TransactionStatus in ([tsTimeOut, tsInvalid, tsCancel, tsAccept, tsReject]) then
  334.        DeleteTransaction
  335.   end; { with }
  336. end;
  337.  
  338. end.
  339.